home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / wb1a1.lha / wb / sys.scm < prev    next >
Encoding:
Text File  |  1993-06-29  |  8.1 KB  |  209 lines
  1. ; Wb-tree File Based Associative String Data Base System.
  2. ; Copyright (c) 1991, 1992, 1993 Holland Mark Martin
  3. ;
  4. ;Permission to use, copy, modify, and distribute this software and its
  5. ;documentation for educational, research, and non-profit purposes and
  6. ;without fee is hereby granted, provided that the above copyright
  7. ;notice appear in all copies and that both that copyright notice and
  8. ;this permission notice appear in supporting documentation, and that
  9. ;the name of Holland Mark Martin not be used in advertising or
  10. ;publicity pertaining to distribution of the software without specific,
  11. ;written prior consent in each case.  Permission to incorporate this
  12. ;software into commercial products can be obtained from Jonathan
  13. ;Finger, Holland Mark Martin, 174 Middlesex Turnpike, Burlington, MA,
  14. ;01803-4467, USA.  Holland Mark Martin makes no representations about
  15. ;the suitability or correctness of this software for any purpose.  It
  16. ;is provided "as is" without express or implied warranty.  Holland Mark
  17. ;Martin is under no obligation to provide any services, by way of
  18. ;maintenance, update, or otherwise.
  19.  
  20. (require 'stdio)
  21. (require (in-vicinity (program-vicinity) "defs"))
  22.  
  23. ;;; This is where all diagnostic and error messages will appear
  24. (define diagout stderr)
  25.  
  26. (define lck-list '())
  27. (define (make-lck name)
  28.   (let ((lk (make-arbiter name)))
  29.     (set! lck-list (cons lk lck-list))
  30.     lk))
  31. (define try-lck try-arbiter)
  32. (define (lck! lck)
  33.   (or (try-arbiter lck)
  34.       (fprintf diagout ">>>>ERROR<<<< spinning %d\\n" lck)))
  35. (define (unlck! lck)
  36.   (or (release-arbiter lck)
  37.       (fprintf diagout ">>>>ERROR<<<< unlcking %d\\n" lck)))
  38. ;;; this fixes lcks - testing only
  39. (define (check-lcks)
  40.   (for-each
  41.    (lambda (l)
  42.      (and (release-arbiter l)
  43.       (fprintf diagout ">>>>ERROR<<<< %d left lcked\\n" l)))
  44.    lck-list))
  45.  
  46. (define (free! x)
  47.   (if x #f (fprintf diagout ">>>>ERROR<<<< free!: object already freed\\n")))
  48. (define (substring-move! src start end dst dstart)
  49.   (if (eq? src dst)
  50.       (fprintf diagout ">>>>ERROR<<<< substring-move!: called with same string\\n"))
  51.   (substring-move-left! src start end dst dstart))
  52.  
  53. ;;;; read-string and write-string are only used in blkio.scm, but are
  54. ;;; here for their C equivalents.
  55.  
  56. (define (write-string fildes buffer nbytes)
  57.   (cond ((= nbytes (string-length buffer))
  58.      (display buffer fildes)
  59.      nbytes)
  60.     ((< nbytes (string-length buffer))
  61.      (display (substring buffer 0 nbytes) fildes)
  62.      nbytes)
  63.     (else 0)))
  64.  
  65. (define (read-string fildes buffer nbytes)
  66.   (cond ((= nbytes (string-length buffer))
  67.      (uniform-vector-read! buffer fildes))
  68.     ((< nbytes (string-length buffer))
  69.      (let* ((tmpbuf (make-string nbytes))
  70.         (numread (uniform-vector-read! tmpbuf fildes)))
  71.        (substring-move! tmpbuf 0 nbytes buffer 0)
  72.        numread))
  73.     (else 0)))
  74.  
  75. ;;; The handle is a HAN
  76. ;;; [HAN-SEG, HAN-ID, HAN-TYP, HAN-LAST, HAN-WriteControlBits]
  77. ;;; HAN-ID is always the root of a B-tree.
  78.  
  79. (define (make-han)
  80.   (vector #f #f #f #f 0 #f))
  81.  
  82. (define HAN-ID-POS 0)
  83. (define HAN-SEG-POS 1)
  84. (define HAN-TYP-POS 2)
  85. (define HAN-LAST-POS 3)
  86. (define HAN-WCB-POS 4)
  87. (define HAN-SPARE-POS 5)
  88.  
  89. (define (HAN-ID han) (vector-ref han HAN-ID-POS))
  90. (define (HAN-SEG han) (vector-ref han HAN-SEG-POS))
  91. (define (HAN-TYP han) (vector-ref han HAN-TYP-POS))
  92. (define (HAN-LAST han) (vector-ref han HAN-LAST-POS))
  93. (define (HAN-WCB han) (vector-ref han HAN-WCB-POS))
  94.  
  95. (define (HAN-SET-NUM! han num) (vector-set! han HAN-ID-POS num))
  96. (define (HAN-SET-SEG! han seg) (vector-set! han HAN-SEG-POS seg))
  97. (define (HAN-SET-TYP! han dir) (vector-set! han HAN-TYP-POS dir))
  98. (define (HAN-SET-LAST! han num) (vector-set! han HAN-LAST-POS num))
  99. (define (HAN-SET-WCB! han wcb) (vector-set! han HAN-WCB-POS wcb))
  100.  
  101. ;;; A segment descriptor is a SEGD:
  102. ;;; [SEGD-PORT,            ; file handle for segment
  103. ;;;  SEGD-BSIZ,            ; block-size
  104. ;;;  SEGD-USED,            ; number of blocks used (file-size/SEGD-BSIZ)
  105. ;;;  SEGD-STR,            ; string name of file
  106. ;;;  SEGD-RT-HAN,        ; handle for 0 block
  107. ;;;  SEGD-FL-HAN,        ; handle for free-list block (2)
  108. ;;;  SEGD-LCK,            ; lock for FLC and superblock.
  109. ;;;  SEGD-FCK,            ; lock for the free-list.
  110. ;;;  SEGD-FLC-LEN,        ; number of available blocks in free-list-cache
  111.                     ;-1 means to read in "FLC" image.
  112.                     ;-2 means read only.
  113. ;;;  SEGD-FLC]            ; free-list-cache
  114.  
  115. ;;;; The SEG calls in defs.scm are the same except they take a segment
  116. ;;;; number (index into segd-tab).
  117.  
  118. (define (make-segd i)
  119.   (vector #f 0 #f #f (make-han) (make-han)
  120.       (make-lck (+ 1000 i)) (make-lck (+ 2000 i)) 0 #f))
  121.  
  122. (define segd-tab (make-vector NUM-SEGS))
  123. (do ((i NUM-SEGS (- i 1)))
  124.     ((zero? i))
  125.   (vector-set! segd-tab (- i 1) (make-segd (- i 1))))
  126.  
  127. (define SEGD-PORT-POS 0)
  128. (define SEGD-BSIZ-POS 1)
  129. (define SEGD-USED-POS 2)
  130. (define SEGD-STR-POS 3)
  131. (define SEGD-RT-HAN-POS 4)
  132. (define SEGD-FL-HAN-POS 5)
  133. (define SEGD-LCK-POS 6)
  134. (define SEGD-FCK-POS 7)
  135. (define SEGD-FLC-LEN-POS 8)
  136. (define SEGD-FLC-POS 9)
  137.  
  138. (define (SEGD-PORT segd) (vector-ref segd SEGD-PORT-POS))
  139. (define (SEGD-BSIZ segd) (vector-ref segd SEGD-BSIZ-POS))
  140. (define (SEGD-USED segd) (vector-ref segd SEGD-USED-POS))
  141. (define (SEGD-STR segd) (vector-ref segd SEGD-STR-POS))
  142. (define (SEGD-RT-HAN segd) (vector-ref segd SEGD-RT-HAN-POS))
  143. (define (SEGD-FL-HAN segd) (vector-ref segd SEGD-FL-HAN-POS))
  144. (define (SEGD-FLC-LEN segd) (vector-ref segd SEGD-FLC-LEN-POS))
  145. (define (SEGD-FLC segd) (vector-ref segd SEGD-FLC-POS))
  146. (define (SEGD-LCK segd) (vector-ref segd SEGD-LCK-POS))
  147. (define (SEGD-FCK segd) (vector-ref segd SEGD-FCK-POS))
  148.  
  149. (define (SEGD-SET-PORT! segd port) (vector-set! segd SEGD-PORT-POS port))
  150. (define (SEGD-SET-BSIZ! segd bsiz) (vector-set! segd SEGD-BSIZ-POS bsiz))
  151. (define (SEGD-SET-USED! segd used) (vector-set! segd SEGD-USED-POS used))
  152. (define (SEGD-SET-STR! segd str) (vector-set! segd SEGD-STR-POS str))
  153. (define (SEGD-SET-FLC-LEN! segd flc-len) (vector-set! segd SEGD-FLC-LEN-POS flc-len))
  154. (define (SEGD-SET-FLC! segd flc) (vector-set! segd SEGD-FLC-POS flc))
  155.  
  156.  
  157. ;;; The hash table element is an ENT:
  158. ;;; [ENT-TAG            ; The number of this entry (diagnostic).
  159. ;;;  ENT-NEXT            ; The next entry in this bucket (hash table element)
  160. ;;;  ENT-SEG            ; segment number for this entry
  161. ;;;  ENT-ID            ; block number for this entry
  162. ;;;  ENT-BLK            ; string of length (SEG-BSIZ (ENT-SEG ent))
  163. ;;;  ENT-AGE            ; aging count.  Gets bigger as time goes on
  164. ;;;  ENT-DTY            ; buffer has been modified
  165. ;;;  ENT-PUS            ; parent update state 1, 0 , -1 , -2
  166. ;;;  ENT-ACC            ; either ACCREAD, ACCWRITE, ACCPEND, or #f.
  167. ;;;  ENT-REF]            ; count of outstanding pointers to this entry and block
  168.  
  169. (define (make-ent tag)
  170.   (vector tag #f -1 -1 (make-string blk-size #\~) 0 #f 0 #f 0))
  171.  
  172. (define ENT-TAG-POS 0)
  173. (define ENT-NEXT-POS 1)
  174. (define ENT-SEG-POS 2)
  175. (define ENT-ID-POS 3) ; blk #
  176. (define ENT-BLK-POS 4)
  177. (define ENT-AGE-POS 5) ; grows with age, starts at 0
  178. (define ENT-DTY-POS 6) ; needs writing out if not #f
  179. (define ENT-PUS-POS 7) ; parent uptdate state.
  180. (define ENT-ACC-POS 8) ; ACC-READ, ACC-WRITE, or ACC-PEND (reading)
  181. (define ENT-REF-POS 9) ; ref count for NAME access
  182.  
  183. (define (ENT-TAG ent) (vector-ref ent ENT-TAG-POS))
  184. (define (ENT-NEXT ent) (vector-ref ent ENT-NEXT-POS))
  185. (define (ENT-SEG ent) (vector-ref ent ENT-SEG-POS))
  186. (define (ENT-ID ent) (vector-ref ent ENT-ID-POS))
  187. (define (ENT-BLK ent) (vector-ref ent ENT-BLK-POS))
  188. (define (ENT-AGE ent) (vector-ref ent ENT-AGE-POS))
  189. (define (ENT-DTY? ent) (vector-ref ent ENT-DTY-POS))
  190. (define (ENT-ACC ent) (vector-ref ent ENT-ACC-POS))
  191. (define (ENT-PUS ent) (vector-ref ent ENT-PUS-POS))
  192. (define (ENT-REF ent) (vector-ref ent ENT-REF-POS))
  193.  
  194. (define (ENT-SET-TAG! ent tag) (vector-set! ent ENT-TAG-POS tag))
  195. (define (ENT-SET-NEXT! ent next) (vector-set! ent ENT-NEXT-POS next))
  196. (define (ENT-SET-SEG! ent seg) (vector-set! ent ENT-SEG-POS seg))
  197. (define (ENT-SET-ID! ent num) (vector-set! ent ENT-ID-POS num))
  198. (define (ENT-SET-AGE! ent age) (vector-set! ent ENT-AGE-POS age))
  199. (define (ENT-SET-DTY! ent dty) (vector-set! ent ENT-DTY-POS dty))
  200. (define (ENT-SET-PUS! ent pus) (vector-set! ent ENT-PUS-POS pus))
  201. (define (ENT-SET-ACC! ent acc) (vector-set! ent ENT-ACC-POS acc))
  202. (define (ENT-SET-REF! ent ref) (vector-set! ent ENT-REF-POS ref))
  203.  
  204. ;;; BLK PREDICATES
  205.  
  206. (define (ROOT? blk) (= (BLK-ID blk) (BLK-TOP-ID blk)))
  207.  
  208. (define (END-OF-CHAIN? blk) (zero? (BLK-NXT-ID blk)))
  209.